home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl5 / LWP / Simple.pm < prev    next >
Text File  |  2008-04-07  |  9KB  |  353 lines
  1. package LWP::Simple;
  2.  
  3. use strict;
  4. use vars qw($ua %loop_check $FULL_LWP @EXPORT @EXPORT_OK $VERSION);
  5.  
  6. require Exporter;
  7.  
  8. @EXPORT = qw(get head getprint getstore mirror);
  9. @EXPORT_OK = qw($ua);
  10.  
  11. # I really hate this.  I was a bad idea to do it in the first place.
  12. # Wonder how to get rid of it???  (It even makes LWP::Simple 7% slower
  13. # for trivial tests)
  14. use HTTP::Status;
  15. push(@EXPORT, @HTTP::Status::EXPORT);
  16.  
  17. $VERSION = "5.810";
  18. $FULL_LWP++ if grep {lc($_) eq "http_proxy"} keys %ENV;
  19.  
  20.  
  21. sub import
  22. {
  23.     my $pkg = shift;
  24.     my $callpkg = caller;
  25.     if (grep $_ eq '$ua', @_) {
  26.     $FULL_LWP++;
  27.     _init_ua();
  28.     }
  29.     Exporter::export($pkg, $callpkg, @_);
  30. }
  31.  
  32.  
  33. sub _init_ua
  34. {
  35.     require LWP;
  36.     require LWP::UserAgent;
  37.     require HTTP::Status;
  38.     require HTTP::Date;
  39.     $ua = new LWP::UserAgent;  # we create a global UserAgent object
  40.     my $ver = $LWP::VERSION = $LWP::VERSION;  # avoid warning
  41.     $ua->agent("LWP::Simple/$LWP::VERSION");
  42.     $ua->env_proxy;
  43. }
  44.  
  45.  
  46. sub get ($)
  47. {
  48.     %loop_check = ();
  49.     goto \&_get;
  50. }
  51.  
  52.  
  53. sub get_old ($)
  54. {
  55.     my($url) = @_;
  56.     _init_ua() unless $ua;
  57.  
  58.     my $request = HTTP::Request->new(GET => $url);
  59.     my $response = $ua->request($request);
  60.  
  61.     return $response->content if $response->is_success;
  62.     return undef;
  63. }
  64.  
  65.  
  66. sub head ($)
  67. {
  68.     my($url) = @_;
  69.     _init_ua() unless $ua;
  70.  
  71.     my $request = HTTP::Request->new(HEAD => $url);
  72.     my $response = $ua->request($request);
  73.  
  74.     if ($response->is_success) {
  75.     return $response unless wantarray;
  76.     return (scalar $response->header('Content-Type'),
  77.         scalar $response->header('Content-Length'),
  78.         HTTP::Date::str2time($response->header('Last-Modified')),
  79.         HTTP::Date::str2time($response->header('Expires')),
  80.         scalar $response->header('Server'),
  81.            );
  82.     }
  83.     return;
  84. }
  85.  
  86.  
  87. sub getprint ($)
  88. {
  89.     my($url) = @_;
  90.     _init_ua() unless $ua;
  91.  
  92.     my $request = HTTP::Request->new(GET => $url);
  93.     local($\) = ""; # ensure standard $OUTPUT_RECORD_SEPARATOR
  94.     my $callback = sub { print $_[0] };
  95.     if ($^O eq "MacOS") {
  96.     $callback = sub { $_[0] =~ s/\015?\012/\n/g; print $_[0] }
  97.     }
  98.     my $response = $ua->request($request, $callback);
  99.     unless ($response->is_success) {
  100.     print STDERR $response->status_line, " <URL:$url>\n";
  101.     }
  102.     $response->code;
  103. }
  104.  
  105.  
  106. sub getstore ($$)
  107. {
  108.     my($url, $file) = @_;
  109.     _init_ua() unless $ua;
  110.  
  111.     my $request = HTTP::Request->new(GET => $url);
  112.     my $response = $ua->request($request, $file);
  113.  
  114.     $response->code;
  115. }
  116.  
  117.  
  118. sub mirror ($$)
  119. {
  120.     my($url, $file) = @_;
  121.     _init_ua() unless $ua;
  122.     my $response = $ua->mirror($url, $file);
  123.     $response->code;
  124. }
  125.  
  126.  
  127. sub _get
  128. {
  129.     my $url = shift;
  130.     my $ret;
  131.     if (!$FULL_LWP && $url =~ m,^http://([^/:\@]+)(?::(\d+))?(/\S*)?$,) {
  132.     my $host = $1;
  133.     my $port = $2 || 80;
  134.     my $path = $3;
  135.     $path = "/" unless defined($path);
  136.     return _trivial_http_get($host, $port, $path);
  137.     }
  138.     else {
  139.         _init_ua() unless $ua;
  140.     if (@_ && $url !~ /^\w+:/) {
  141.         # non-absolute redirect from &_trivial_http_get
  142.         my($host, $port, $path) = @_;
  143.         require URI;
  144.         $url = URI->new_abs($url, "http://$host:$port$path");
  145.     }
  146.     my $request = HTTP::Request->new(GET => $url);
  147.     my $response = $ua->request($request);
  148.     return $response->is_success ? $response->content : undef;
  149.     }
  150. }
  151.  
  152.  
  153. sub _trivial_http_get
  154. {
  155.    my($host, $port, $path) = @_;
  156.    #print "HOST=$host, PORT=$port, PATH=$path\n";
  157.  
  158.    require IO::Socket;
  159.    local($^W) = 0;
  160.    my $sock = IO::Socket::INET->new(PeerAddr => $host,
  161.                                     PeerPort => $port,
  162.                                     Proto    => 'tcp',
  163.                                     Timeout  => 60) || return undef;
  164.    $sock->autoflush;
  165.    my $netloc = $host;
  166.    $netloc .= ":$port" if $port != 80;
  167.    print $sock join("\015\012" =>
  168.                     "GET $path HTTP/1.0",
  169.                     "Host: $netloc",
  170.                     "User-Agent: lwp-trivial/$VERSION",
  171.                     "", "");
  172.  
  173.    my $buf = "";
  174.    my $n;
  175.    1 while $n = sysread($sock, $buf, 8*1024, length($buf));
  176.    return undef unless defined($n);
  177.  
  178.    if ($buf =~ m,^HTTP/\d+\.\d+\s+(\d+)[^\012]*\012,) {
  179.        my $code = $1;
  180.        #print "CODE=$code\n$buf\n";
  181.        if ($code =~ /^30[1237]/ && $buf =~ /\012Location:\s*(\S+)/i) {
  182.            # redirect
  183.            my $url = $1;
  184.            return undef if $loop_check{$url}++;
  185.            return _get($url, $host, $port, $path);
  186.        }
  187.        return undef unless $code =~ /^2/;
  188.        $buf =~ s/.+?\015?\012\015?\012//s;  # zap header
  189.    }
  190.  
  191.    return $buf;
  192. }
  193.  
  194.  
  195. 1;
  196.  
  197. __END__
  198.  
  199. =head1 NAME
  200.  
  201. LWP::Simple - simple procedural interface to LWP
  202.  
  203. =head1 SYNOPSIS
  204.  
  205.  perl -MLWP::Simple -e 'getprint "http://www.sn.no"'
  206.  
  207.  use LWP::Simple;
  208.  $content = get("http://www.sn.no/");
  209.  die "Couldn't get it!" unless defined $content;
  210.  
  211.  if (mirror("http://www.sn.no/", "foo") == RC_NOT_MODIFIED) {
  212.      ...
  213.  }
  214.  
  215.  if (is_success(getprint("http://www.sn.no/"))) {
  216.      ...
  217.  }
  218.  
  219. =head1 DESCRIPTION
  220.  
  221. This module is meant for people who want a simplified view of the
  222. libwww-perl library.  It should also be suitable for one-liners.  If
  223. you need more control or access to the header fields in the requests
  224. sent and responses received, then you should use the full object-oriented
  225. interface provided by the C<LWP::UserAgent> module.
  226.  
  227. The following functions are provided (and exported) by this module:
  228.  
  229. =over 3
  230.  
  231. =item get($url)
  232.  
  233. The get() function will fetch the document identified by the given URL
  234. and return it.  It returns C<undef> if it fails.  The $url argument can
  235. be either a simple string or a reference to a URI object.
  236.  
  237. You will not be able to examine the response code or response headers
  238. (like 'Content-Type') when you are accessing the web using this
  239. function.  If you need that information you should use the full OO
  240. interface (see L<LWP::UserAgent>).
  241.  
  242. =item head($url)
  243.  
  244. Get document headers. Returns the following 5 values if successful:
  245. ($content_type, $document_length, $modified_time, $expires, $server)
  246.  
  247. Returns an empty list if it fails.  In scalar context returns TRUE if
  248. successful.
  249.  
  250. =item getprint($url)
  251.  
  252. Get and print a document identified by a URL. The document is printed
  253. to the selected default filehandle for output (normally STDOUT) as
  254. data is received from the network.  If the request fails, then the
  255. status code and message are printed on STDERR.  The return value is
  256. the HTTP response code.
  257.  
  258. =item getstore($url, $file)
  259.  
  260. Gets a document identified by a URL and stores it in the file. The
  261. return value is the HTTP response code.
  262.  
  263. =item mirror($url, $file)
  264.  
  265. Get and store a document identified by a URL, using
  266. I<If-modified-since>, and checking the I<Content-Length>.  Returns
  267. the HTTP response code.
  268.  
  269. =back
  270.  
  271. This module also exports the HTTP::Status constants and procedures.
  272. You can use them when you check the response code from getprint(),
  273. getstore() or mirror().  The constants are:
  274.  
  275.    RC_CONTINUE
  276.    RC_SWITCHING_PROTOCOLS
  277.    RC_OK
  278.    RC_CREATED
  279.    RC_ACCEPTED
  280.    RC_NON_AUTHORITATIVE_INFORMATION
  281.    RC_NO_CONTENT
  282.    RC_RESET_CONTENT
  283.    RC_PARTIAL_CONTENT
  284.    RC_MULTIPLE_CHOICES
  285.    RC_MOVED_PERMANENTLY
  286.    RC_MOVED_TEMPORARILY
  287.    RC_SEE_OTHER
  288.    RC_NOT_MODIFIED
  289.    RC_USE_PROXY
  290.    RC_BAD_REQUEST
  291.    RC_UNAUTHORIZED
  292.    RC_PAYMENT_REQUIRED
  293.    RC_FORBIDDEN
  294.    RC_NOT_FOUND
  295.    RC_METHOD_NOT_ALLOWED
  296.    RC_NOT_ACCEPTABLE
  297.    RC_PROXY_AUTHENTICATION_REQUIRED
  298.    RC_REQUEST_TIMEOUT
  299.    RC_CONFLICT
  300.    RC_GONE
  301.    RC_LENGTH_REQUIRED
  302.    RC_PRECONDITION_FAILED
  303.    RC_REQUEST_ENTITY_TOO_LARGE
  304.    RC_REQUEST_URI_TOO_LARGE
  305.    RC_UNSUPPORTED_MEDIA_TYPE
  306.    RC_INTERNAL_SERVER_ERROR
  307.    RC_NOT_IMPLEMENTED
  308.    RC_BAD_GATEWAY
  309.    RC_SERVICE_UNAVAILABLE
  310.    RC_GATEWAY_TIMEOUT
  311.    RC_HTTP_VERSION_NOT_SUPPORTED
  312.  
  313. The HTTP::Status classification functions are:
  314.  
  315. =over 3
  316.  
  317. =item is_success($rc)
  318.  
  319. True if response code indicated a successful request.
  320.  
  321. =item is_error($rc)
  322.  
  323. True if response code indicated that an error occurred.
  324.  
  325. =back
  326.  
  327. The module will also export the LWP::UserAgent object as C<$ua> if you
  328. ask for it explicitly.
  329.  
  330. The user agent created by this module will identify itself as
  331. "LWP::Simple/#.##" (where "#.##" is the libwww-perl version number)
  332. and will initialize its proxy defaults from the environment (by
  333. calling $ua->env_proxy).
  334.  
  335. =head1 CAVEAT
  336.  
  337. Note that if you are using both LWP::Simple and the very popular CGI.pm
  338. module, you may be importing a C<head> function from each module,
  339. producing a warning like "Prototype mismatch: sub main::head ($) vs
  340. none". Get around this problem by just not importing LWP::Simple's
  341. C<head> function, like so:
  342.  
  343.         use LWP::Simple qw(!head);
  344.         use CGI qw(:standard);  # then only CGI.pm defines a head()
  345.  
  346. Then if you do need LWP::Simple's C<head> function, you can just call
  347. it as C<LWP::Simple::head($url)>.
  348.  
  349. =head1 SEE ALSO
  350.  
  351. L<LWP>, L<lwpcook>, L<LWP::UserAgent>, L<HTTP::Status>, L<lwp-request>,
  352. L<lwp-mirror>
  353.